home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1993 July / InfoMagic USENET CD-ROM July 1993.ISO / sources / misc / volume13 / gmcalc / part06 < prev    next >
Encoding:
Text File  |  1990-06-05  |  57.0 KB  |  2,015 lines
  1. Newsgroups: comp.sources.misc
  2. From: daveg@csvax.caltech.edu (David Gillespie)
  3. Subject: v13i032: Emacs Calculator 1.01, part 06/19
  4. Sender: allbery@uunet.UU.NET (Brandon S. Allbery - comp.sources.misc)
  5.  
  6. Posting-number: Volume 13, Issue 32
  7. Submitted-by: daveg@csvax.caltech.edu (David Gillespie)
  8. Archive-name: gmcalc/part06
  9.  
  10. ---- Cut Here and unpack ----
  11. #!/bin/sh
  12. # this is part 6 of a multipart archive
  13. # do not concatenate these parts, unpack them in order with /bin/sh
  14. # file calc-ext.el continued
  15. #
  16. CurArch=6
  17. if test ! -r s2_seq_.tmp
  18. then echo "Please unpack part 1 first!"
  19.      exit 1; fi
  20. ( read Scheck
  21.   if test "$Scheck" != $CurArch
  22.   then echo "Please unpack part $Scheck next!"
  23.        exit 1;
  24.   else exit 0; fi
  25. ) < s2_seq_.tmp || exit 1
  26. echo "x - Continuing file calc-ext.el"
  27. sed 's/^X//' << 'SHAR_EOF' >> calc-ext.el
  28. X      (setq msgs (cons buf msgs)
  29. X        buf "")
  30. X      (calc-user-function-list kmap 6))
  31. X    (if (/= flags 0)
  32. X    (setq msgs (cons buf msgs)))
  33. X    (calc-do-prefix-help (nreverse msgs) "user" ?z))
  34. X)
  35. X
  36. X(defun calc-user-function-classify (key)
  37. X  (cond ((/= key (downcase key))    ; upper-case
  38. X     (if (assq (downcase key) (calc-user-key-map)) 9 1))
  39. X    ((/= key (upcase key)) 2)   ; lower-case
  40. X    ((= key ??) 0)
  41. X    (t 4))   ; other
  42. X)
  43. X
  44. X(defun calc-user-function-list (map flags)
  45. X  (and map
  46. X       (let* ((key (car (car map)))
  47. X          (kind (calc-user-function-classify key))
  48. X          (func (cdr (car map))))
  49. X     (if (= (logand kind flags) 0)
  50. X         ()
  51. X       (let* ((name (symbol-name func))
  52. X          (name (if (string-match "\\`calc-" name)
  53. X                (substring name 5) name))
  54. X          (pos (string-match (char-to-string key) name))
  55. X          (desc
  56. X           (if (symbolp func)
  57. X               (if (= (logand kind 3) 0)
  58. X               (format "`%c' = %s" key name)
  59. X             (if pos
  60. X                 (format "%s%c%s"
  61. X                     (downcase (substring name 0 pos))
  62. X                     (upcase key)
  63. X                     (downcase (substring name (1+ pos))))
  64. X               (format "%c = %s"
  65. X                   (upcase key)
  66. X                   (downcase name))))
  67. X             (char-to-string (upcase key)))))
  68. X         (if (= (length buf) 0)
  69. X         (setq buf (concat (if (= flags 1) "SHIFT + " "")
  70. X                   desc))
  71. X           (if (> (+ (length buf) (length desc)) 58)
  72. X           (setq msgs (cons buf msgs)
  73. X             buf (concat (if (= flags 1) "SHIFT + " "")
  74. X                     desc))
  75. X         (setq buf (concat buf ", " desc))))))
  76. X     (calc-user-function-list (cdr map) flags)))
  77. X)
  78. X
  79. X
  80. X
  81. X(defun calc-shift-Z-prefix-help ()
  82. X  (interactive)
  83. X  (calc-do-prefix-help
  84. X   '("Define, Undefine, Formula, Kbd-macro, Edit, Get-defn"
  85. X     "Permanent; Var-perm"
  86. X     "kbd-macros: [ (if), : (else), | (else-if), ] (end-if)"
  87. X     "kbd-macros: < > (repeat), ( ) (for), { } (loop)"
  88. X     "kbd-macros: / (break)"
  89. X     "kbd-macros: ` (save), ' (restore)")
  90. X   "user" ?Z)
  91. X)
  92. X
  93. X(defun calc-user-define ()
  94. X  "Bind a Calculator command to a key sequence using the z prefix."
  95. X  (interactive)
  96. X  (message "Define user key: z-")
  97. X  (let ((key (read-char)))
  98. X    (if (= (calc-user-function-classify key) 0)
  99. X    (error "Can't redefine \"?\" key"))
  100. X    (let ((func (intern (completing-read (concat "Set key z "
  101. X                         (char-to-string key)
  102. X                         " to command: ")
  103. X                     obarray
  104. X                     'commandp
  105. X                     t
  106. X                     "calc-"))))
  107. X      (let* ((kmap (calc-user-key-map))
  108. X         (old (assq key kmap)))
  109. X    (if old
  110. X        (setcdr old func)
  111. X      (setcdr kmap (cons (cons key func) (cdr kmap)))))))
  112. X)
  113. X
  114. X(defun calc-user-undefine ()
  115. X  "Remove the definition on a Calculator z prefix key."
  116. X  (interactive)
  117. X  (message "Undefine user key: z-")
  118. X  (let ((key (read-char)))
  119. X    (if (= (calc-user-function-classify key) 0)
  120. X    (error "Can't undefine \"?\" key"))
  121. X    (let* ((kmap (calc-user-key-map)))
  122. X      (delq (or (assq key kmap)
  123. X        (assq (upcase key) kmap)
  124. X        (assq (downcase key) kmap)
  125. X        (error "No such user key is defined"))
  126. X        kmap)))
  127. X)
  128. X
  129. X(defun calc-user-define-formula ()
  130. X  "Define a new Calculator z-prefix command using formula at top of stack."
  131. X  (interactive)
  132. X  (calc-wrapper
  133. X   (let* ((form (calc-top 1))
  134. X      (arglist nil)
  135. X      odef key keyname cmd cmd-base func alist is-symb)
  136. X     (calc-default-formula-arglist form)
  137. X     (setq arglist (sort arglist 'string-lessp))
  138. X     (message "Define user key: z-")
  139. X     (setq key (read-char))
  140. X     (if (= (calc-user-function-classify key) 0)
  141. X     (error "Can't redefine \"?\" key"))
  142. X     (setq key (and (not (memq key '(13 32))) key)
  143. X       keyname (and key
  144. X            (if (or (and (<= ?0 key) (<= key ?9))
  145. X                (and (<= ?a key) (<= key ?z))
  146. X                (and (<= ?A key) (<= key ?Z)))
  147. X                (char-to-string key)
  148. X              (format "%03d" key)))
  149. X       odef (assq key (calc-user-key-map)))
  150. X     (while
  151. X     (progn
  152. X       (setq cmd (completing-read "Define M-x command name: "
  153. X                      obarray 'commandp nil
  154. X                      (if (and odef (symbolp (cdr odef)))
  155. X                      (symbol-name (cdr odef))
  156. X                    "calc-"))
  157. X         cmd-base (and (string-match "\\`calc-\\(.+\\)\\'" cmd)
  158. X                   (math-match-substring cmd 1))
  159. X         cmd (and (not (or (string-equal cmd "")
  160. X                   (string-equal cmd "calc-")))
  161. X              (intern cmd)))
  162. X       (and cmd
  163. X        (fboundp cmd)
  164. X        odef
  165. X        (not
  166. X         (y-or-n-p
  167. X          (if (get cmd 'calc-user-defn)
  168. X              (concat "Replace previous definition for "
  169. X                  (symbol-name cmd) "? ")
  170. X            "That name conflicts with a built-in Emacs function.  Replace this function? "))))))
  171. X     (if (and key (not cmd))
  172. X     (setq cmd (intern (concat "calc-User-" keyname))))
  173. X     (while
  174. X     (progn
  175. X       (setq func (completing-read "Define algebraic function name: "
  176. X                       obarray 'fboundp nil
  177. X                       (concat "calcFunc-"
  178. X                           (if cmd-base
  179. X                           (if (string-match
  180. X                            "\\`User-.+" cmd-base)
  181. X                               (concat
  182. X                            "User"
  183. X                            (substring cmd-base 5))
  184. X                             cmd-base)
  185. X                         "")))
  186. X         func (and (not (or (string-equal func "")
  187. X                    (string-equal func "calcFunc-")))
  188. X               (intern func)))
  189. X       (and func
  190. X        (fboundp func)
  191. X        (not (fboundp cmd))
  192. X        odef
  193. X        (not
  194. X         (y-or-n-p
  195. X          (if (get func 'calc-user-defn)
  196. X              (concat "Replace previous definition for "
  197. X                  (symbol-name func) "? ")
  198. X            "That name conflicts with a built-in Emacs function.  Replace this function? "))))))
  199. X     (if (not func)
  200. X     (setq func (intern (concat "calcFunc-User"
  201. X                    (or keyname
  202. X                    (and cmd (symbol-name cmd))
  203. X                    (format "%05d" (% (random) 10000)))))))
  204. X     (while
  205. X     (progn
  206. X       (setq alist (read-from-minibuffer "Function argument list: "
  207. X                         (if arglist
  208. X                         (prin1-to-string arglist)
  209. X                           "()")
  210. X                         minibuffer-local-map
  211. X                         t))
  212. X       (and (not (calc-subsetp alist arglist))
  213. X        (y-or-n-p
  214. X         "Okay for arguments that don't appear in formula to be ignored? "))))
  215. X     (setq is-symb (and alist
  216. X            func
  217. X            (y-or-n-p
  218. X             "Leave it symbolic for non-constant arguments? ")))
  219. X     (if cmd
  220. X     (progn
  221. X       (fset cmd
  222. X         (list 'lambda
  223. X               '()
  224. X               "User-defined Calculator function."
  225. X               '(interactive)
  226. X               (list 'calc-wrapper
  227. X                 (list 'calc-enter-result
  228. X                   (length alist)
  229. X                   (let ((name (symbol-name (or func cmd))))
  230. X                     (and (string-match
  231. X                       "\\([^-][^-]?[^-]?[^-]?\\)[^-]*\\'"
  232. X                       name)
  233. X                      (math-match-substring name 1)))
  234. X                   (list 'cons
  235. X                     (list 'quote func)
  236. X                     (list 'calc-top-list-n
  237. X                           (length alist)))))))
  238. X       (put cmd 'calc-user-defn t)))
  239. X     (let ((body (list 'math-normalize (calc-fix-user-formula form))))
  240. X       (fset func
  241. X         (append
  242. X          (list 'lambda alist)
  243. X          (and is-symb
  244. X           (mapcar (function (lambda (v)
  245. X                       (list 'math-check-const v)))
  246. X               alist))
  247. X          (list body))))
  248. X     (put func 'calc-user-defn form)
  249. X     (if key
  250. X     (let* ((kmap (calc-user-key-map))
  251. X        (old (assq key kmap)))
  252. X       (if old
  253. X           (setcdr old cmd)
  254. X         (setcdr kmap (cons (cons key cmd) (cdr kmap)))))))
  255. X   (message ""))
  256. X)
  257. X
  258. X(defun calc-default-formula-arglist (form)
  259. X  (if (consp form)
  260. X      (if (eq (car form) 'var)
  261. X      (if (or (memq (nth 1 form) arglist)
  262. X          (boundp (nth 2 form)))
  263. X          ()
  264. X        (setq arglist (cons (nth 1 form) arglist)))
  265. X    (calc-default-formula-arglist-step (cdr form))))
  266. X)
  267. X
  268. X(defun calc-default-formula-arglist-step (l)
  269. X  (and l
  270. X       (progn
  271. X     (calc-default-formula-arglist (car l))
  272. X     (calc-default-formula-arglist-step (cdr l))))
  273. X)
  274. X
  275. X(defun calc-subsetp (a b)
  276. X  (or (null a)
  277. X      (and (memq (car a) b)
  278. X       (calc-subsetp (cdr a) b)))
  279. X)
  280. X
  281. X(defun calc-fix-user-formula (f)
  282. X  (if (consp f)
  283. X      (cond ((and (eq (car f) 'var)
  284. X          (memq (nth 1 f) alist))
  285. X         (nth 1 f))
  286. X        ((math-constp f)
  287. X         (list 'quote f))
  288. X        (t
  289. X         (cons 'list
  290. X           (cons (list 'quote (car f))
  291. X             (mapcar 'calc-fix-user-formula (cdr f))))))
  292. X    f)
  293. X)
  294. X
  295. X
  296. X(defun calc-user-define-kbd-macro (arg)
  297. X  "Bind the most recent keyboard macro to a key sequence using the z prefix."
  298. X  (interactive "P")
  299. X  (or last-kbd-macro
  300. X      (error "No keyboard macro defined"))
  301. X  (message "Define last kbd macro on user key: z-")
  302. X  (let ((key (read-char)))
  303. X    (if (= (calc-user-function-classify key) 0)
  304. X    (error "Can't redefine \"?\" key"))
  305. X    (let ((cmd (intern (completing-read "Full name for new command: "
  306. X                    obarray
  307. X                    'commandp
  308. X                    nil
  309. X                    (concat "calc-User-"
  310. X                        (if (or (and (>= key ?a)
  311. X                                 (<= key ?z))
  312. X                            (and (>= key ?A)
  313. X                                 (<= key ?Z))
  314. X                            (and (>= key ?0)
  315. X                                 (<= key ?9)))
  316. X                            (char-to-string key)
  317. X                          (format "%03d" key)))))))
  318. X      (and (fboundp cmd)
  319. X       (not (let ((f (symbol-function cmd)))
  320. X          (or (stringp f)
  321. X              (and (consp f)
  322. X               (eq (car-safe (nth 3 f))
  323. X                   'calc-execute-kbd-macro)))))
  324. X       (error "Function %s is already defined and not a keyboard macro"
  325. X          cmd))
  326. X      (put cmd 'calc-user-defn t)
  327. X      (fset cmd (if (< (prefix-numeric-value arg) 0)
  328. X            last-kbd-macro
  329. X          (list 'lambda
  330. X            '(arg)
  331. X            '(interactive "P")
  332. X            (list 'calc-execute-kbd-macro
  333. X                  last-kbd-macro
  334. X                  'arg))))
  335. X      (let* ((kmap (calc-user-key-map))
  336. X         (old (assq key kmap)))
  337. X    (if old
  338. X        (setcdr old cmd)
  339. X      (setcdr kmap (cons (cons key cmd) (cdr kmap)))))))
  340. X)
  341. X
  342. X
  343. X(defun calc-user-define-edit (prefix)
  344. X  "Edit the definition of a z-prefix command."
  345. X  (interactive "P")  ; but no calc-wrapper!
  346. X  (message "Edit definition of command: z-")
  347. X  (let* ((key (read-char))
  348. X     (def (or (assq key (calc-user-key-map))
  349. X          (assq (upcase key) (calc-user-key-map))
  350. X          (assq (downcase key) (calc-user-key-map))
  351. X          (error "No command defined for that key")))
  352. X     (cmd (cdr def)))
  353. X    (if (symbolp cmd)
  354. X    (setq cmd (symbol-function cmd)))
  355. X    (cond ((or (stringp cmd)
  356. X           (and (consp cmd)
  357. X            (eq (car-safe (nth 3 cmd)) 'calc-execute-kbd-macro)))
  358. X       (if (and (>= (prefix-numeric-value prefix) 0)
  359. X            (fboundp 'edit-kbd-macro)
  360. X            (symbolp (cdr def))
  361. X            (eq major-mode 'calc-mode))
  362. X           (progn
  363. X         (if (and (< (window-width) (screen-width))
  364. X              calc-display-trail)
  365. X             (let* ((trail (get-buffer-create "*Calc Trail*"))
  366. X                (win (get-buffer-window trail)))
  367. X               (if win
  368. X               (delete-window win))))
  369. X         (edit-kbd-macro (cdr def) prefix nil
  370. X                 (function
  371. X                  (lambda (x)
  372. X                    (and calc-display-trail
  373. X                     (calc-wrapper
  374. X                      (calc-trail-display 1 t)))))
  375. X                 (function
  376. X                  (lambda (cmd)
  377. X                    (if (stringp (symbol-function cmd))
  378. X                    (symbol-function cmd)
  379. X                      (nth 1 (nth 3 (symbol-function cmd))))))
  380. X                 (function
  381. X                  (lambda (new cmd)
  382. X                    (if (stringp (symbol-function cmd))
  383. X                    (fset cmd new)
  384. X                      (setcar (cdr (nth 3 (symbol-function
  385. X                               cmd)))
  386. X                          new))))))
  387. X         (calc-wrapper
  388. X          (calc-edit-mode (list 'calc-finish-macro-edit
  389. X                    (list 'quote def)))
  390. X          (insert (if (stringp cmd)
  391. X              cmd
  392. X            (nth 1 (nth 3 cmd)))))
  393. X         (calc-show-edit-buffer)))
  394. X      (t (let* ((func (calc-stack-command-p cmd))
  395. X            (defn (and func
  396. X                   (symbolp func)
  397. X                   (get func 'calc-user-defn))))
  398. X           (if (and defn (calc-valid-formula-func func))
  399. X           (progn
  400. X             (calc-wrapper
  401. X              (calc-edit-mode (list 'calc-finish-formula-edit
  402. X                        (list 'quote func)))
  403. X              (insert (math-format-flat-expr defn 0) "\n"))
  404. X             (calc-show-edit-buffer))
  405. X         (error "That command's definition cannot be edited"))))))
  406. X)
  407. X
  408. X(defun calc-finish-macro-edit (def)
  409. X  (let ((str (buffer-substring (point) (point-max))))
  410. X    (if (symbolp (cdr def))
  411. X    (if (stringp (symbol-function (cdr def)))
  412. X        (fset (cdr def) str)
  413. X      (setcar (cdr (nth 3 (symbol-function (cdr def)))) str))
  414. X      (setcdr def str)))
  415. X)
  416. X
  417. X;;; The following are hooks into the MacEdit package from macedit.el.
  418. X(put 'calc-execute-extended-command 'MacEdit-print
  419. X     (function (lambda ()
  420. X         (setq macro-str (concat "\excalc-" macro-str))))
  421. X)
  422. X
  423. X(put 'calcDigit-start 'MacEdit-print
  424. X     (function (lambda ()
  425. X         (if calc-algebraic-mode
  426. X             (calc-macro-edit-algebraic)
  427. X           (MacEdit-unread-chars key-last)
  428. X           (let ((str "")
  429. X             (min-bsp 0)
  430. X             ch last)
  431. X             (while (and (setq ch (MacEdit-read-char))
  432. X                 (or (and (>= ch ?0) (<= ch ?9))
  433. X                     (memq ch '(?\. ?e ?\_ ?n ?\: ?\# ?M
  434. X                            ?o ?h ?\@ ?\"))
  435. X                     (and (memq ch '(?\' ?m ?s))
  436. X                      (string-match "[@oh]" str))
  437. X                     (and (or (and (>= ch ?a) (<= ch ?z))
  438. X                          (and (>= ch ?A) (<= ch ?Z)))
  439. X                      (string-match
  440. X                       "^[-+]?\\(1[1-9]\\|[2-9][0-9]\\)#"
  441. X                       str))
  442. X                     (and (memq ch '(?\177 ?\C-h))
  443. X                      (> (length str) 0))
  444. X                     (and (memq ch '(?+ ?-))
  445. X                      (> (length str) 0)
  446. X                      (eq (aref str (1- (length str)))
  447. X                          ?e))))
  448. X               (if (or (and (>= ch ?0) (<= ch ?9))
  449. X                   (and (or (not (memq ch '(?\177 ?\C-h)))
  450. X                    (<= (length str) min-bsp))
  451. X                    (setq min-bsp (1+ (length str)))))
  452. X               (setq str (concat str (char-to-string ch)))
  453. X             (setq str (substring str 0 -1))))
  454. X             (if (memq ch '(32 10 13))
  455. X             (setq str (concat str (char-to-string ch)))
  456. X               (MacEdit-unread-chars ch))
  457. X             (insert "type \"")
  458. X             (MacEdit-insert-string str)
  459. X             (insert "\"\n")))))
  460. X)
  461. X
  462. X(defun calc-macro-edit-algebraic ()
  463. X  (MacEdit-unread-chars key-last)
  464. X  (let ((str "")
  465. X    (min-bsp 0))
  466. X    (while (progn
  467. X         (MacEdit-lookup-key calc-alg-ent-map)
  468. X         (or (and (memq key-symbol '(self-insert-command
  469. X                     calcAlg-previous))
  470. X              (< (length str) 60))
  471. X         (memq key-symbol
  472. X                '(backward-delete-char
  473. X                  delete-backward-char
  474. X                  backward-delete-char-untabify))
  475. X         (eq key-last 9)))
  476. X      (setq macro-str (substring macro-str (length key-str)))
  477. X      (if (or (eq key-symbol 'self-insert-command)
  478. X          (and (or (not (memq key-symbol '(backward-delete-char
  479. X                           delete-backward-char
  480. X                           backward-delete-char-untabify)))
  481. X               (<= (length str) min-bsp))
  482. X           (setq min-bsp (+ (length str) (length key-str)))))
  483. X      (setq str (concat str key-str))
  484. X    (setq str (substring str 0 -1))))
  485. X    (if (memq key-last '(10 13))
  486. X    (setq str (concat str key-str)
  487. X          macro-str (substring macro-str (length key-str))))
  488. X    (if (> (length str) 0)
  489. X    (progn
  490. X      (insert "type \"")
  491. X      (MacEdit-insert-string str)
  492. X      (insert "\"\n"))))
  493. X)
  494. X(put 'calc-algebraic-entry 'MacEdit-print 'calc-macro-edit-algebraic)
  495. X(put 'calc-dollar-sign 'MacEdit-print 'calc-macro-edit-algebraic)
  496. X
  497. X(defun calc-macro-edit-variable ()
  498. X  (let ((str "") ch)
  499. X    (insert (symbol-name key-symbol) "\n")
  500. X    (if (memq (MacEdit-peek-char) '(?\+ ?\- ?\* ?\/ ?\^ ?\|))
  501. X    (setq str (char-to-string (MacEdit-read-char))))
  502. X    (if (and (setq ch (MacEdit-peek-char))
  503. X         (>= ch ?0) (<= ch ?9))
  504. X    (insert "type \"" str
  505. X        (char-to-string (MacEdit-read-char)) "\"\n")
  506. X      (if (> (length str) 0)
  507. X      (insert "type \"" str "\"\n"))
  508. X      (MacEdit-read-argument)))
  509. X)
  510. X(put 'calc-store 'MacEdit-print 'calc-macro-edit-variable)
  511. X(put 'calc-recall 'MacEdit-print 'calc-macro-edit-variable)
  512. X(put 'calc-let 'MacEdit-print 'calc-macro-edit-variable)
  513. X
  514. X
  515. X(defun calc-finish-formula-edit (func)
  516. X  (let ((buf (current-buffer))
  517. X    (str (buffer-substring (point) (point-max)))
  518. X    (start (point))
  519. X    (body (calc-valid-formula-func func)))
  520. X    (set-buffer calc-original-buffer)
  521. X    (let ((val (math-read-expr str)))
  522. X      (if (eq (car-safe val) 'error)
  523. X      (progn
  524. X        (set-buffer buf)
  525. X        (goto-char (+ start (nth 1 val)))
  526. X        (error (nth 2 val))))
  527. X      (setcar (cdr body)
  528. X          (let ((alist (nth 1 (symbol-function func))))
  529. X        (calc-fix-user-formula val)))
  530. X      (put func 'calc-user-defn val)))
  531. X)
  532. X
  533. X(defun calc-valid-formula-func (func)
  534. X  (let ((def (symbol-function func)))
  535. X    (and (consp def)
  536. X     (eq (car def) 'lambda)
  537. X     (progn
  538. X       (setq def (cdr (cdr def)))
  539. X       (while (and def
  540. X               (not (eq (car (car def)) 'math-normalize)))
  541. X         (setq def (cdr def)))
  542. X       (car def))))
  543. X)
  544. X
  545. X
  546. X(defun calc-get-user-defn ()
  547. X  "Extract the definition from a z-prefix command as a formula."
  548. X  (interactive)
  549. X  (calc-wrapper
  550. X   (message "Get definition of command: z-")
  551. X   (let* ((key (read-char))
  552. X      (def (or (assq key (calc-user-key-map))
  553. X           (assq (upcase key) (calc-user-key-map))
  554. X           (assq (downcase key) (calc-user-key-map))
  555. X           (error "No command defined for that key")))
  556. X      (cmd (cdr def)))
  557. X     (if (symbolp cmd)
  558. X     (setq cmd (symbol-function cmd)))
  559. X     (cond ((stringp cmd)
  560. X        (message "Keyboard macro: %s" cmd))
  561. X       (t (let* ((func (calc-stack-command-p cmd))
  562. X             (defn (and func
  563. X                (symbolp func)
  564. X                (get func 'calc-user-defn))))
  565. X        (if defn
  566. X            (calc-enter-result 0 "gdef" defn)
  567. X          (error "That command is not defined by a formula")))))))
  568. X)
  569. X
  570. X
  571. X(defun calc-user-define-permanent ()
  572. X  "Make a user definition permanent by storing it in your .emacs file."
  573. X  (interactive)
  574. X  (calc-wrapper
  575. X   (message "Record in %s the command: z-" calc-settings-file)
  576. X   (let* ((key (read-char))
  577. X      (def (or (assq key (calc-user-key-map))
  578. X           (assq (upcase key) (calc-user-key-map))
  579. X           (assq (downcase key) (calc-user-key-map))
  580. X           (error "No command defined for that key"))))
  581. X     (set-buffer (find-file-noselect (substitute-in-file-name
  582. X                      calc-settings-file)))
  583. X     (goto-char (point-max))
  584. X     (insert "\n;;; Definition stored by Calc on " (current-time-string)
  585. X         "\n(setq calc-defs (append '(\n")
  586. X     (let* ((cmd (cdr def))
  587. X        (fcmd (and cmd (symbolp cmd) (symbol-function cmd)))
  588. X        (pt (point))
  589. X        (fill-column 70))
  590. X       (if (and fcmd
  591. X        (eq (car-safe fcmd) 'lambda)
  592. X        (get cmd 'calc-user-defn))
  593. X       (progn
  594. X         (insert (prin1-to-string
  595. X              (cons 'defun (cons cmd (cdr fcmd))))
  596. X             "\n")
  597. X         (fill-region pt (point))
  598. X         (indent-rigidly pt (point) 3)
  599. X         (delete-region pt (1+ pt))
  600. X         (let* ((func (calc-stack-command-p cmd))
  601. X            (ffunc (and func (symbolp func) (symbol-function func)))
  602. X            (pt (point)))
  603. X           (and ffunc
  604. X            (eq (car-safe ffunc) 'lambda)
  605. X            (get func 'calc-user-defn)
  606. X            (progn
  607. X              (insert (prin1-to-string
  608. X                   (cons 'defun (cons func (cdr ffunc))))
  609. X                  "\n")
  610. X              (fill-region pt (point))
  611. X              (indent-rigidly pt (point) 3)
  612. X              (delete-region pt (1+ pt))))))
  613. X     (and (stringp fcmd)
  614. X          (insert "  (fset '" (prin1-to-string cmd)
  615. X              " " (prin1-to-string fcmd) ")\n")))
  616. X       (insert "  (define-key calc-mode-map "
  617. X           (prin1-to-string (concat "z" (char-to-string key)))
  618. X           " '"
  619. X           (prin1-to-string cmd)
  620. X           "))\n"))
  621. X     (insert " (and (boundp 'calc-defs) calc-defs)))\n")
  622. X     (save-buffer)))
  623. X)
  624. X
  625. X(defun calc-stack-command-p (cmd)
  626. X  (if (and cmd (symbolp cmd))
  627. X      (and (fboundp cmd)
  628. X       (calc-stack-command-p (symbol-function cmd)))
  629. X    (and (consp cmd)
  630. X     (eq (car cmd) 'lambda)
  631. X     (setq cmd (or (assq 'calc-wrapper cmd)
  632. X               (assq 'calc-slow-wrapper cmd)))
  633. X     (setq cmd (assq 'calc-enter-result cmd))
  634. X     (memq (car (nth 3 cmd)) '(cons list))
  635. X     (eq (car (nth 1 (nth 3 cmd))) 'quote)
  636. X     (nth 1 (nth 1 (nth 3 cmd)))))
  637. X)
  638. X
  639. X(defun calc-permanent-variable ()
  640. X  "Save a variable's value in your .emacs file."
  641. X  (interactive)
  642. X  (calc-wrapper
  643. X   (let ((var (let ((minibuffer-completion-table obarray)
  644. X            (minibuffer-completion-predicate 'boundp)
  645. X            (minibuffer-completion-confirm t)
  646. X            (oper "r"))
  647. X        (read-from-minibuffer
  648. X         "Save variable: " "var-" calc-store-var-map nil)))
  649. X     pos)
  650. X     (if (equal var "")
  651. X     ()
  652. X       (or (and (boundp (intern var)) (intern var))
  653. X       (error "No such variable"))
  654. X       (set-buffer (find-file-noselect (substitute-in-file-name
  655. X                    calc-settings-file)))
  656. X       (goto-char (point-min))
  657. X       (if (search-forward (concat "(setq " var " '") nil t)
  658. X       (progn
  659. X         (setq pos (point-marker))
  660. X         (forward-line -1)
  661. X         (if (looking-at ";;; Variable .* stored by Calc on ")
  662. X         (progn
  663. X           (delete-region (match-end 0) (progn (end-of-line) (point)))
  664. X           (insert (current-time-string))))
  665. X         (goto-char (- pos 8 (length var)))
  666. X         (forward-sexp 1)
  667. X         (backward-char 1)
  668. X         (delete-region pos (point)))
  669. X     (goto-char (point-max))
  670. X     (insert "\n;;; Variable \""
  671. X         var
  672. X         "\" stored by Calc on "
  673. X         (current-time-string)
  674. X         "\n(setq "
  675. X         var
  676. X         " ')\n")
  677. X     (backward-char 2))
  678. X       (insert (prin1-to-string (symbol-value (intern var))))
  679. X       (forward-line 1)
  680. X       (save-buffer))))
  681. X)
  682. X
  683. X
  684. X
  685. X(defun calc-call-last-kbd-macro (arg)
  686. X  "Execute the most recent keyboard macro."
  687. X  (interactive "P")
  688. X  (and defining-kbd-macro
  689. X       (error "Can't execute anonymous macro while defining one"))
  690. X  (or last-kbd-macro
  691. X      (error "No kbd macro has been defined"))
  692. X  (calc-execute-kbd-macro last-kbd-macro arg)
  693. X)
  694. X
  695. X(defun calc-execute-kbd-macro (mac arg)
  696. X  (if (< (prefix-numeric-value arg) 0)
  697. X      (execute-kbd-macro mac (- (prefix-numeric-value arg)))
  698. X    (if calc-executing-macro
  699. X    (execute-kbd-macro mac arg)
  700. X      (calc-slow-wrapper
  701. X       (let ((old-stack-whole (copy-sequence calc-stack))
  702. X         (old-stack-top calc-stack-top)
  703. X         (old-buffer-size (buffer-size))
  704. X         (old-refresh-count calc-refresh-count))
  705. X     (unwind-protect
  706. X         (let ((calc-executing-macro mac))
  707. X           (execute-kbd-macro mac arg))
  708. X       (calc-select-buffer)
  709. X       (let ((new-stack (reverse calc-stack))
  710. X         (old-stack (reverse old-stack-whole)))
  711. X         (while (and new-stack old-stack
  712. X             (equal (car new-stack) (car old-stack)))
  713. X           (setq new-stack (cdr new-stack)
  714. X             old-stack (cdr old-stack)))
  715. X         (calc-record-list (mapcar 'car new-stack) "kmac")
  716. X         (calc-record-undo (list 'set 'saved-stack-top old-stack-top))
  717. X         (and old-stack
  718. X          (calc-record-undo (list 'pop 1 (mapcar 'car old-stack))))
  719. X         (let ((calc-stack old-stack-whole)
  720. X           (calc-stack-top 0))
  721. X           (calc-cursor-stack-index (length old-stack)))
  722. X         (if (and (= old-buffer-size (buffer-size))
  723. X              (= old-refresh-count calc-refresh-count))
  724. X         (let ((buffer-read-only nil))
  725. X           (delete-region (point) (point-max))
  726. X           (while new-stack
  727. X             (calc-record-undo (list 'push 1))
  728. X             (let ((fmt (math-format-stack-value
  729. X                 (car (car new-stack)))))
  730. X               (setcar (cdr (car new-stack)) (calc-count-lines fmt))
  731. X               (insert fmt "\n"))
  732. X             (setq new-stack (cdr new-stack)))
  733. X           (calc-renumber-stack))
  734. X           (calc-refresh))
  735. X         (calc-record-undo (list 'set 'saved-stack-top 0))))))))
  736. X)
  737. X
  738. X
  739. X(defun calc-kbd-if ()
  740. X  "An \"if\" statement in a Calc keyboard macro.
  741. XUsage:  cond  Z[  then-part  Z:  cond  Z|  else-if-part ...  Z:  else-part  Z]"
  742. X  (interactive)
  743. X  (calc-wrapper
  744. X   (let ((cond (calc-top-n 1)))
  745. X     (calc-pop-stack 1)
  746. X     (if (math-is-true cond)
  747. X     (if defining-kbd-macro
  748. X         (message "If true..."))
  749. X       (if defining-kbd-macro
  750. X       (message "Condition is false; skipping to Z: or Z] ..."))
  751. X       (calc-kbd-skip-to-else-if t))))
  752. X)
  753. X
  754. X(defun calc-kbd-else-if ()
  755. X  (interactive)
  756. X  (calc-kbd-if)
  757. X)
  758. X
  759. X(defun calc-kbd-skip-to-else-if (else-okay)
  760. X  (let ((count 0)
  761. X    ch)
  762. X    (while (>= count 0)
  763. X      (setq ch (read-char))
  764. X      (if (= ch -1)
  765. X      (error "Unterminated Z[ in keyboard macro"))
  766. X      (if (= ch ?Z)
  767. X      (progn
  768. X        (setq ch (read-char))
  769. X        (cond ((= ch ?\[)
  770. X           (setq count (1+ count)))
  771. X          ((= ch ?\])
  772. X           (setq count (1- count)))
  773. X          ((= ch ?\:)
  774. X           (and (= count 0)
  775. X            else-okay
  776. X            (setq count -1)))
  777. X          ((eq ch 7)
  778. X           (keyboard-quit))))))
  779. X    (and defining-kbd-macro
  780. X     (if (= ch ?\:)
  781. X         (message "Else...")
  782. X       (message "End-if..."))))
  783. X)
  784. X
  785. X(defun calc-kbd-end-if ()
  786. X  (interactive)
  787. X  (if defining-kbd-macro
  788. X      (message "End-if..."))
  789. X)
  790. X
  791. X(defun calc-kbd-else ()
  792. X  (interactive)
  793. X  (if defining-kbd-macro
  794. X      (message "Else; skipping to Z] ..."))
  795. X  (calc-kbd-skip-to-else-if nil)
  796. X)
  797. X
  798. X
  799. X(defun calc-kbd-repeat ()
  800. X  "A counted loop in a Calc keyboard macro.
  801. XUsage:  count  Z<  body  Z>
  802. X
  803. XAny number of break-commands may be embedded in the body:
  804. X   cond  Z/  stops the loop prematurely if cond is true."
  805. X  (interactive)
  806. X  (let (count)
  807. X    (calc-wrapper
  808. X     (setq count (math-trunc (calc-top-n 1)))
  809. X     (or (Math-integerp count)
  810. X     (error "Count must be an integer"))
  811. X     (if (Math-integer-negp count)
  812. X     (setq count 0))
  813. X     (or (integerp count)
  814. X     (setq count 1000000))
  815. X     (calc-pop-stack 1))
  816. X    (calc-kbd-loop count))
  817. X)
  818. X
  819. X(defun calc-kbd-for (dir)
  820. X  "A counted loop in a Calc keyboard macro.
  821. XUsage:  initial  final  Z(  body  step  Z)
  822. X
  823. XDuring the loop, an internal counter is incremented from INITIAL to FINAL
  824. Xin steps of STEP.  The Z( command pops INITIAL and FINAL, and pushes the
  825. Xcurrent counter value each time through the loop.  The Z) command pops
  826. XSTEP.  If INITIAL < FINAL, the loop terminates as soon as the counter
  827. Xexceeds FINAL.  If INITIAL > FINAL, the loop terminates as soon as the
  828. Xcounter becomes less than FINAL.  If INITIAL = FINAL, the loop executes
  829. Xonce.  If INITIAL and FINAL cannot be compared (say because at least one
  830. Xis a symbolic formula), the loop continues until it is halted with Z/.
  831. XNo matter what the relationship between INITIAL and FINAL, the body
  832. Xalways executes at least once.
  833. X
  834. XA numeric prefix argument specifies a forced direction:  If 1, the loop
  835. Xterminates when the counter exceeds FINAL, and will execute zero times
  836. Xif INITIAL > FINAL.  Likewise, -1 forces a downward-counting loop.
  837. X
  838. XAny number of break-commands may be embedded in the body:
  839. X   cond  Z/  stops the loop prematurely if cond is true."
  840. X  (interactive "P")
  841. X  (let (init final)
  842. X    (calc-wrapper
  843. X     (setq init (calc-top-n 2)
  844. X       final (calc-top-n 1))
  845. X     (or (and (math-anglep init) (math-anglep final))
  846. X     (error "Initial and final values must be real numbers"))
  847. X     (calc-pop-stack 2))
  848. X    (calc-kbd-loop nil init final (and dir (prefix-numeric-value dir))))
  849. X)
  850. X
  851. X(defun calc-kbd-loop (rpt-count &optional initial final dir)
  852. X  "A conditional loop in a Calc keyboard macro.
  853. XUsage:  Z{  body  Z}
  854. X
  855. XAt least one break-command is normally present in the body:
  856. X   cond  Z/  stops the loop if cond is true.
  857. X
  858. XWith a numeric prefix argument, loops at most that many times."
  859. X  (interactive "P")
  860. X  (setq rpt-count (if rpt-count (prefix-numeric-value rpt-count) 1000000))
  861. X  (let* ((count 0)
  862. X     (parts nil)
  863. X     (body "")
  864. X     (open last-command-char)
  865. X     (counter initial)
  866. X     ch)
  867. X    (or executing-macro
  868. X    (message "Reading loop body..."))
  869. X    (while (>= count 0)
  870. X      (setq ch (read-char))
  871. X      (if (= ch -1)
  872. X      (error "Unterminated Z%c in keyboard macro" open))
  873. X      (if (= ch ?Z)
  874. X      (progn
  875. X        (setq ch (read-char)
  876. X          body (concat body "Z" (char-to-string ch)))
  877. X        (cond ((memq ch '(?\< ?\( ?\{))
  878. X           (setq count (1+ count)))
  879. X          ((memq ch '(?\> ?\) ?\}))
  880. X           (setq count (1- count)))
  881. X          ((and (= ch ?/)
  882. X            (= count 0))
  883. X           (setq parts (nconc parts (list (substring body 0 -2)))
  884. X             body ""))
  885. X          ((eq ch 7)
  886. X           (keyboard-quit))))
  887. X    (setq body (concat body (char-to-string ch)))))
  888. X    (if (/= ch (cdr (assq open '( (?\< . ?\>) (?\( . ?\)) (?\{ . ?\}) ))))
  889. X    (error "Mismatched Z%c and Z%c in keyboard macro" open ch))
  890. X    (or executing-macro
  891. X    (message "Looping..."))
  892. X    (setq body (substring body 0 -2))
  893. X    (and (not executing-macro)
  894. X     (= rpt-count 1000000)
  895. X     (null parts)
  896. X     (null counter)
  897. X     (progn
  898. X       (message "Warning: Infinite loop!  Not executing.")
  899. X       (setq rpt-count 0)))
  900. X    (or (not initial) dir
  901. X    (setq dir (math-compare final initial)))
  902. X    (calc-wrapper
  903. X     (while (> rpt-count 0)
  904. X       (let ((part parts))
  905. X     (if counter
  906. X         (if (cond ((eq dir 0) (math-equal final counter))
  907. X               ((eq dir 1) (math-lessp final counter))
  908. X               ((eq dir -1) (math-lessp counter final)))
  909. X         (setq rpt-count 0)
  910. X           (calc-push counter)))
  911. X     (while (and part (> rpt-count 0))
  912. X       (execute-kbd-macro (car part))
  913. X       (if (math-is-true (calc-top-n 1))
  914. X           (setq rpt-count 0)
  915. X         (setq part (cdr part)))
  916. X       (calc-pop-stack 1))
  917. X     (if (> rpt-count 0)
  918. X         (progn
  919. X           (execute-kbd-macro body)
  920. X           (if counter
  921. X           (let ((step (calc-top-n 1)))
  922. X             (calc-pop-stack 1)
  923. X             (setq counter (calcFunc-add counter step)))
  924. X         (setq rpt-count (1- rpt-count))))))))
  925. X    (or executing-macro
  926. X    (message "Looping...done")))
  927. X)
  928. X
  929. X(defun calc-kbd-end-repeat ()
  930. X  (interactive)
  931. X  (error "Unbalanced Z> in keyboard macro")
  932. X)
  933. X
  934. X(defun calc-kbd-end-for ()
  935. X  (interactive)
  936. X  (error "Unbalanced Z) in keyboard macro")
  937. X)
  938. X
  939. X(defun calc-kbd-end-loop ()
  940. X  (interactive)
  941. X  (error "Unbalanced Z} in keyboard macro")
  942. X)
  943. X
  944. X(defun calc-kbd-break ()
  945. X  "Break out of a keyboard macro, or out of a Z< Z> or Z{ Z} loop in a macro.
  946. XUsage:  cond  Z/    breaks only if cond is true.  Use \"1 Z/\" to break always."
  947. X  (interactive)
  948. X  (calc-wrapper
  949. X   (let ((cond (calc-top-n 1)))
  950. X     (calc-pop-stack 1)
  951. X     (if (math-is-true cond)
  952. X     (error "Keyboard macro aborted."))))
  953. X)
  954. X
  955. X
  956. X(defun calc-kbd-push ()
  957. X  "Save modes and quick variables around a section of a keyboard macro.
  958. X
  959. XSaved:  var-0 thru var-9, precision, word size, angular mode,
  960. Xsimplification mode, vector mapping direction, Alg, Sym, Frac, Polar modes.
  961. X
  962. XValues are restored on exit, even if the macro halts with an error."
  963. X  (interactive)
  964. X  (calc-wrapper
  965. X   (let* ((var-0 (and (boundp 'var-0) var-0))
  966. X      (var-1 (and (boundp 'var-1) var-1))
  967. X      (var-2 (and (boundp 'var-2) var-2))
  968. X      (var-3 (and (boundp 'var-3) var-3))
  969. X      (var-4 (and (boundp 'var-4) var-4))
  970. X      (var-5 (and (boundp 'var-5) var-5))
  971. X      (var-6 (and (boundp 'var-6) var-6))
  972. X      (var-7 (and (boundp 'var-7) var-7))
  973. X      (var-8 (and (boundp 'var-8) var-8))
  974. X      (var-9 (and (boundp 'var-9) var-9))
  975. X      (calc-internal-prec calc-internal-prec)
  976. X      (calc-word-size calc-word-size)
  977. X      (calc-angle-mode calc-angle-mode)
  978. X      (calc-simplify-mode calc-simplify-mode)
  979. X      (calc-mapping-dir calc-mapping-dir)
  980. X      (calc-algebraic-mode calc-algebraic-mode)
  981. X      (calc-symbolic-mode calc-symbolic-mode)
  982. X      (calc-prefer-frac calc-prefer-frac)
  983. X      (calc-complex-mode calc-complex-mode)
  984. X      (count 0)
  985. X      (body "")
  986. X      ch)
  987. X     (if (or executing-macro defining-kbd-macro)
  988. X     (progn
  989. X       (if defining-kbd-macro
  990. X           (message "Reading body..."))
  991. X       (while (>= count 0)
  992. X         (setq ch (read-char))
  993. X         (if (= ch -1)
  994. X         (error "Unterminated Z` in keyboard macro"))
  995. X         (if (= ch ?Z)
  996. X         (progn
  997. X           (setq ch (read-char)
  998. X             body (concat body "Z" (char-to-string ch)))
  999. X           (cond ((eq ch ?\`)
  1000. X              (setq count (1+ count)))
  1001. X             ((eq ch ?\')
  1002. X              (setq count (1- count)))
  1003. X             ((eq ch 7)
  1004. X              (keyboard-quit))))
  1005. X           (setq body (concat body (char-to-string ch)))))
  1006. X       (if defining-kbd-macro
  1007. X           (message "Reading body...done"))
  1008. X       (let ((calc-kbd-push-level 0))
  1009. X         (execute-kbd-macro (substring body 0 -2))))
  1010. X       (let ((calc-kbd-push-level (1+ calc-kbd-push-level)))
  1011. X     (message "Saving modes; type Z' to restore")
  1012. X     (recursive-edit)))))
  1013. X)
  1014. X(setq calc-kbd-push-level 0)
  1015. X
  1016. X(defun calc-kbd-pop ()
  1017. X  (interactive)
  1018. X  (if (> calc-kbd-push-level 0)
  1019. X      (progn
  1020. X    (message "Mode settings restored")
  1021. X    (exit-recursive-edit))
  1022. X    (error "Unbalanced Z' in keyboard macro"))
  1023. X)
  1024. X
  1025. X
  1026. X(defun calc-kbd-report (msg)
  1027. X  "Display the number on the top of the stack in the echo area.
  1028. XThis will normally be used to report progress in a keyboard macro."
  1029. X  (interactive "sMessage: ")
  1030. X  (calc-wrapper
  1031. X   (let ((executing-macro nil)
  1032. X     (defining-kbd-macro nil))
  1033. X     (math-working msg (calc-top-n 1))))
  1034. X)
  1035. X
  1036. X(defun calc-kbd-query (msg)
  1037. X  "Pause during keyboard macro execution to do an algebraic entry."
  1038. X  (interactive "sPrompt: ")
  1039. X  (calc-wrapper
  1040. X   (let ((executing-macro nil)
  1041. X     (defining-kbd-macro nil))
  1042. X     (calc-alg-entry nil (and (not (equal msg "")) msg))))
  1043. X)
  1044. X
  1045. X
  1046. X
  1047. X
  1048. X
  1049. X
  1050. X;;;; Caches.
  1051. X
  1052. X(defmacro math-defcache (name init form)
  1053. X  (let ((cache-prec (intern (concat (symbol-name name) "-cache-prec")))
  1054. X    (cache-val (intern (concat (symbol-name name) "-cache")))
  1055. X    (last-prec (intern (concat (symbol-name name) "-last-prec")))
  1056. X    (last-val (intern (concat (symbol-name name) "-last"))))
  1057. X    (list 'progn
  1058. X      (list 'setq cache-prec (if init (math-numdigs (nth 1 init)) -100))
  1059. X      (list 'setq cache-val (list 'quote init))
  1060. X      (list 'setq last-prec -100)
  1061. X      (list 'setq last-val nil)
  1062. X      (list 'setq 'math-cache-list
  1063. X        (list 'cons
  1064. X              (list 'quote cache-prec)
  1065. X              (list 'cons
  1066. X                (list 'quote last-prec)
  1067. X                'math-cache-list)))
  1068. X      (list 'defun
  1069. X        name ()
  1070. X        (list 'or
  1071. X              (list '= last-prec 'calc-internal-prec)
  1072. X              (list 'setq
  1073. X                last-val
  1074. X                (list 'math-normalize
  1075. X                  (list 'progn
  1076. X                    (list 'or
  1077. X                          (list '>= cache-prec
  1078. X                            'calc-internal-prec)
  1079. X                          (list 'setq
  1080. X                            cache-val
  1081. X                            (list 'let
  1082. X                              '((calc-internal-prec
  1083. X                                 (+ calc-internal-prec
  1084. X                                4)))
  1085. X                              form)
  1086. X                            cache-prec
  1087. X                            '(+ calc-internal-prec 2)))
  1088. X                    cache-val))
  1089. X                last-prec 'calc-internal-prec))
  1090. X        last-val)))
  1091. X)
  1092. X(put 'math-defcache 'lisp-indent-hook 2)
  1093. X
  1094. X;;; Betcha didn't know that pi = 16 atan(1/5) - 4 atan(1/239).   [F] [Public]
  1095. X(math-defcache math-pi (float (bigpos 463 238 793 589 653 592 141 3) -21)
  1096. X  (math-add-float (math-mul-float '(float 16 0)
  1097. X                  (math-arctan-raw '(float 2 -1)))
  1098. X          (math-mul-float '(float -4 0)
  1099. X                  (math-arctan-raw
  1100. X                   (math-float '(frac 1 239))))))
  1101. X
  1102. X(math-defcache math-two-pi nil
  1103. X  (math-mul-float (math-pi) '(float 2 0)))
  1104. X
  1105. X(math-defcache math-pi-over-2 nil
  1106. X  (math-mul-float (math-pi) '(float 5 -1)))
  1107. X
  1108. X(math-defcache math-pi-over-4 nil
  1109. X  (math-mul-float (math-pi) '(float 25 -2)))
  1110. X
  1111. X(math-defcache math-pi-over-180 nil
  1112. X  (math-div-float (math-pi) '(float 18 1)))
  1113. X
  1114. X(math-defcache math-sqrt-e (float (bigpos 849 146 128 700 270 721 648 1) -21)
  1115. X  (math-add-float '(float 1 0) (math-exp-minus-1-raw '(float 5 -1))))
  1116. X
  1117. X(math-defcache math-e nil
  1118. X  (math-sqr (math-sqrt-e)))
  1119. X
  1120. X
  1121. X(defun math-half-circle (symb)
  1122. X  (if (eq calc-angle-mode 'rad)
  1123. X      (if symb
  1124. X      '(var pi var-pi)
  1125. X    (math-pi))
  1126. X    180)
  1127. X)
  1128. X
  1129. X(defun math-full-circle (symb)
  1130. X  (math-mul 2 (math-half-circle symb))
  1131. X)
  1132. X
  1133. X(defun math-quarter-circle (symb)
  1134. X  (math-div (math-half-circle symb) 2)
  1135. X)
  1136. X
  1137. X
  1138. X
  1139. X
  1140. X;;;; Miscellaneous math routines.
  1141. X
  1142. X;;; True if A is an odd integer.  [P R R] [Public]
  1143. X(defun math-oddp (a)
  1144. X  (if (consp a)
  1145. X      (and (memq (car a) '(bigpos bigneg))
  1146. X       (= (% (nth 1 a) 2) 1))
  1147. X    (/= (% a 2) 0))
  1148. X)
  1149. X
  1150. X;;; True if A is numerically an integer.  [P x] [Public]
  1151. X(defun math-num-integerp (a)
  1152. X  (or (Math-integerp a)
  1153. X      (Math-messy-integerp a))
  1154. X)
  1155. X(defmacro Math-num-integerp (a)
  1156. X  (` (or (not (consp (, a)))
  1157. X     (memq (car (, a)) '(bigpos bigneg))
  1158. X     (and (eq (car (, a)) 'float)
  1159. X          (>= (nth 2 (, a)) 0))))
  1160. X)
  1161. X
  1162. X;;; True if A is (numerically) a non-negative integer.  [P N] [Public]
  1163. X(defun math-num-natnump (a)
  1164. X  (or (natnump a)
  1165. X      (eq (car-safe a) 'bigpos)
  1166. X      (and (eq (car-safe a) 'float)
  1167. X       (Math-natnump (nth 1 a))
  1168. X       (>= (nth 2 a) 0)))
  1169. X)
  1170. X
  1171. X;;; True if A is an integer or will evaluate to an integer.  [P x] [Public]
  1172. X(defun math-provably-integerp (a)
  1173. X  (or (Math-integerp a)
  1174. X      (memq (car-safe a) '(calcFunc-trunc
  1175. X               calcFunc-round
  1176. X               calcFunc-floor
  1177. X               calcFunc-ceil)))
  1178. X)
  1179. X
  1180. X;;; True if A is a real or will evaluate to a real.  [P x] [Public]
  1181. X(defun math-provably-realp (a)
  1182. X  (or (Math-realp a)
  1183. X      (math-provably-integer a)
  1184. X      (memq (car-safe a) '(abs arg)))
  1185. X)
  1186. X
  1187. X;;; True if A is a non-real, complex number.  [P x] [Public]
  1188. X(defun math-complexp (a)
  1189. X  (memq (car-safe a) '(cplx polar))
  1190. X)
  1191. X
  1192. X;;; True if A is a non-real, rectangular complex number.  [P x] [Public]
  1193. X(defun math-rect-complexp (a)
  1194. X  (eq (car-safe a) 'cplx)
  1195. X)
  1196. X
  1197. X;;; True if A is a non-real, polar complex number.  [P x] [Public]
  1198. X(defun math-polar-complexp (a)
  1199. X  (eq (car-safe a) 'polar)
  1200. X)
  1201. X
  1202. X;;; True if A is a matrix.  [P x] [Public]
  1203. X(defun math-matrixp (a)
  1204. X  (and (Math-vectorp a)
  1205. X       (Math-vectorp (nth 1 a))
  1206. X       (cdr (nth 1 a))
  1207. X       (math-matrixp-step (cdr (cdr a)) (length (nth 1 a))))
  1208. X)
  1209. X
  1210. X(defun math-matrixp-step (a len)   ; [P L]
  1211. X  (or (null a)
  1212. X      (and (Math-vectorp (car a))
  1213. X       (= (length (car a)) len)
  1214. X       (math-matrixp-step (cdr a) len)))
  1215. X)
  1216. X
  1217. X;;; True if A is a square matrix.  [P V] [Public]
  1218. X(defun math-square-matrixp (a)
  1219. X  (let ((dims (math-mat-dimens a)))
  1220. X    (and (cdr dims)
  1221. X     (= (car dims) (nth 1 dims))))
  1222. X)
  1223. X
  1224. X;;; True if A is any real scalar data object.  [P x]
  1225. X(defun math-real-objectp (a)    ;  [Public]
  1226. X  (or (integerp a)
  1227. X      (memq (car-safe a) '(bigpos bigneg frac float hms sdev intv mod)))
  1228. X)
  1229. X
  1230. X;;; True if A is an object not composed of sub-formulas .  [P x] [Public]
  1231. X(defun math-primp (a)
  1232. X  (or (integerp a)
  1233. X      (memq (car-safe a) '(bigpos bigneg frac float cplx polar
  1234. X                  hms mod var)))
  1235. X)
  1236. X(defmacro Math-primp (a)
  1237. X  (` (or (not (consp (, a)))
  1238. X     (memq (car (, a)) '(bigpos bigneg frac float cplx polar
  1239. X                    hms mod var))))
  1240. X)
  1241. X
  1242. X;;; True if A is a constant or vector of constants.  [P x] [Public]
  1243. X(defun math-constp (a)
  1244. X  (or (math-scalarp a)
  1245. X      (and (memq (car-safe a) '(sdev intv vec))
  1246. X       (progn
  1247. X         (while (and (setq a (cdr a))
  1248. X             (math-constp (car a))))
  1249. X         (null a))))
  1250. X)
  1251. X
  1252. X(defmacro Math-lessp (a b)
  1253. X  (` (= (math-compare (, a) (, b)) -1))
  1254. X)
  1255. X
  1256. X
  1257. X;;; Verify that A is an integer and return A in integer form.  [I N; - x]
  1258. X(defun math-check-integer (a)   ;  [Public]
  1259. X  (cond ((integerp a) a)  ; for speed
  1260. X    ((math-integerp a) a)
  1261. X    ((math-messy-integerp a)
  1262. X     (math-trunc a))
  1263. X    (t (math-reject-arg a 'integerp)))
  1264. X)
  1265. X
  1266. X;;; Verify that A is a small integer and return A in integer form.  [S N; - x]
  1267. X(defun math-check-fixnum (a)   ;  [Public]
  1268. X  (cond ((integerp a) a)  ; for speed
  1269. X    ((Math-num-integerp a)
  1270. X     (let ((a (math-trunc a)))
  1271. X       (if (integerp a)
  1272. X           a
  1273. X         (if (or (Math-lessp (lsh -1 -1) a)
  1274. X             (Math-lessp a (- (lsh -1 -1))))
  1275. X         (math-reject-arg a 'fixnump)
  1276. X           (math-fixnum a)))))
  1277. X    (t (math-reject-arg a 'fixnump)))
  1278. X)
  1279. X
  1280. X;;; Verify that A is an integer >= 0 and return A in integer form.  [I N; - x]
  1281. X(defun math-check-natnum (a)    ;  [Public]
  1282. X  (cond ((natnump a) a)
  1283. X    ((and (not (math-negp a))
  1284. X          (Math-num-integerp a))
  1285. X     (math-trunc a))
  1286. X    (t (math-reject-arg a 'natnump)))
  1287. X)
  1288. X
  1289. X;;; Verify that A is in floating-point form, or force it to be a float.  [F N]
  1290. X(defun math-check-float (a)    ; [Public]
  1291. X  (cond ((eq (car-safe a) 'float) a)
  1292. X    ((Math-vectorp a) (math-map-vec 'math-check-float a))
  1293. X    ((Math-objectp a) (math-float a))
  1294. X    (t a))
  1295. X)
  1296. X
  1297. X;;; Verify that A is a constant.
  1298. X(defun math-check-const (a)
  1299. X  (if (math-constp a)
  1300. X      a
  1301. X    (math-reject-arg a 'constp))
  1302. X)
  1303. X
  1304. X
  1305. X;;; Coerce integer A to be a small integer.  [S I]
  1306. X(defun math-fixnum (a)
  1307. X  (if (consp a)
  1308. X      (if (cdr a)
  1309. X      (if (eq (car a) 'bigneg)
  1310. X          (- (math-fixnum-big (cdr a)))
  1311. X        (math-fixnum-big (cdr a)))
  1312. X    0)
  1313. X    a)
  1314. X)
  1315. X
  1316. X(defun math-fixnum-big (a)
  1317. X  (if (cdr a)
  1318. X      (+ (car a) (* (math-fixnum-big (cdr a)) 1000))
  1319. X    (car a))
  1320. X)
  1321. X
  1322. X
  1323. X(defun math-bignum-test (a)   ; [B N; B s; b b]
  1324. X  (if (consp a)
  1325. X      a
  1326. X    (math-bignum a))
  1327. X)
  1328. X(defmacro Math-bignum-test (a)   ; [B N; B s; b b]
  1329. X  (` (if (consp (, a))
  1330. X     (, a)
  1331. X       (math-bignum (, a))))
  1332. X)
  1333. X
  1334. X
  1335. X;;; Return 0 for zero, -1 for negative, 1 for positive.  [S n] [Public]
  1336. X(defun math-sign (a)
  1337. X  (cond ((math-posp a) 1)
  1338. X    ((math-negp a) -1)
  1339. X    ((math-zerop a) 0)
  1340. X    (t (calc-record-why 'realp a)
  1341. X       (list 'calcFunc-sign a)))
  1342. X)
  1343. X(fset 'calcFunc-sign (symbol-function 'math-sign))
  1344. X
  1345. X;;; Return 0 if A is numerically equal to B, <0 if less, >0 if more.
  1346. X;;; Arguments must be normalized!  [S N N]
  1347. X(defun math-compare (a b)
  1348. X  (cond ((equal a b) 0)
  1349. X    ((and (integerp a) (Math-integerp b))
  1350. X     (if (consp b)
  1351. X         (if (eq (car b) 'bigpos) -1 1)
  1352. X       (if (< a b) -1 1)))
  1353. X    ((and (eq (car-safe a) 'bigpos) (Math-integerp b))
  1354. X     (if (eq (car-safe b) 'bigpos)
  1355. X         (math-compare-bignum (cdr a) (cdr b))
  1356. X       1))
  1357. X    ((and (eq (car-safe a) 'bigneg) (Math-integerp b))
  1358. X     (if (eq (car-safe b) 'bigneg)
  1359. X         (math-compare-bignum (cdr b) (cdr a))
  1360. X       -1))
  1361. X    ((eq (car-safe a) 'frac)
  1362. X     (if (eq (car-safe b) 'frac)
  1363. X         (math-compare (math-mul (nth 1 a) (nth 2 b))
  1364. X               (math-mul (nth 1 b) (nth 2 a)))
  1365. X       (math-compare (nth 1 a) (math-mul b (nth 2 a)))))
  1366. X    ((eq (car-safe b) 'frac)
  1367. X     (math-compare (math-mul a (nth 2 b)) (nth 1 b)))
  1368. X    ((and (eq (car-safe a) 'float) (eq (car-safe b) 'float))
  1369. X     (if (math-lessp-float a b) -1 1))
  1370. X    ((and (Math-anglep a) (Math-anglep b))
  1371. X     (math-sign (math-add a (math-neg b))))
  1372. X    ((eq (car-safe a) 'var)
  1373. X     2)
  1374. X    (t
  1375. X     (if (and (consp a) (consp b)
  1376. X          (eq (car a) (car b))
  1377. X          (math-compare-lists (cdr a) (cdr b)))
  1378. X         0
  1379. X       2)))
  1380. X)
  1381. X
  1382. X;;; Compare two bignum digit lists, return -1 for A<B, 0 for A=B, 1 for A>B.
  1383. X(defun math-compare-bignum (a b)   ; [S l l]
  1384. X  (let ((res 0))
  1385. X    (while (and a b)
  1386. X      (if (< (car a) (car b))
  1387. X      (setq res -1)
  1388. X    (if (> (car a) (car b))
  1389. X        (setq res 1)))
  1390. X      (setq a (cdr a)
  1391. X        b (cdr b)))
  1392. X    (if a
  1393. X    (progn
  1394. X      (while (eq (car a) 0) (setq a (cdr a)))
  1395. X      (if a 1 res))
  1396. X      (while (eq (car b) 0) (setq b (cdr b)))
  1397. X      (if b -1 res)))
  1398. X)
  1399. X
  1400. X(defun math-compare-lists (a b)
  1401. X  (cond ((null a) (null b))
  1402. X    ((null b) nil)
  1403. X    (t (and (math-equal (car a) (car b))
  1404. X        (math-compare-lists (cdr a) (cdr b)))))
  1405. X)
  1406. X
  1407. X(defun math-lessp-float (a b)   ; [P F F]
  1408. X  (let ((ediff (- (nth 2 a) (nth 2 b))))
  1409. X    (if (>= ediff 0)
  1410. X    (if (>= ediff (+ calc-internal-prec calc-internal-prec))
  1411. X        (Math-integer-negp (nth 1 a))
  1412. X      (Math-lessp (math-scale-int (nth 1 a) ediff)
  1413. X              (nth 1 b)))
  1414. X      (if (>= (setq ediff (- ediff))
  1415. X          (+ calc-internal-prec calc-internal-prec))
  1416. X      (Math-integer-posp (nth 1 b))
  1417. X    (Math-lessp (nth 1 a)
  1418. X            (math-scale-int (nth 1 b) ediff)))))
  1419. X)
  1420. X
  1421. X;;; True if A is numerically equal to B.  [P N N] [Public]
  1422. X(defun math-equal (a b)
  1423. X  (= (math-compare a b) 0)
  1424. X)
  1425. X
  1426. X;;; True if A is numerically less than B.  [P R R] [Public]
  1427. X(defun math-lessp (a b)
  1428. X  (= (math-compare a b) -1)
  1429. X)
  1430. X
  1431. X;;; True if A is numerically equal to the integer B.  [P N S] [Public]
  1432. X;;; B must not be a multiple of 10.
  1433. X(defun math-equal-int (a b)
  1434. X  (or (eq a b)
  1435. X      (and (eq (car-safe a) 'float)
  1436. X       (eq (nth 1 a) b)
  1437. X       (= (nth 2 a) 0)))
  1438. X)
  1439. X(defmacro Math-equal-int (a b)
  1440. X  (` (or (eq (, a) (, b))
  1441. X     (and (consp (, a))
  1442. X          (eq (car (, a)) 'float)
  1443. X          (eq (nth 1 (, a)) (, b))
  1444. X          (= (nth 2 (, a)) 0))))
  1445. X)
  1446. X
  1447. X
  1448. X;;; Convert a variable name (as a formula) into a like-looking function name.
  1449. X(defun math-var-to-calcFunc (f)
  1450. X  (if (eq (car-safe f) 'var)
  1451. X      (if (fboundp (nth 2 f))
  1452. X      (nth 2 f)
  1453. X    (intern (concat "calcFunc-" (symbol-name (nth 1 f)))))
  1454. X    (if (memq (car-safe f) '(lambda calcFunc-lambda))
  1455. X    f
  1456. X      (math-reject-arg f "Expected a function name")))
  1457. X)
  1458. X
  1459. X;;; Convert a function name into a like-looking variable name formula.
  1460. X(defun math-calcFunc-to-var (f)
  1461. X  (if (symbolp f)
  1462. X      (let ((base (if (string-match "\\`calcFunc-\\(.+\\)\\'" (symbol-name f))
  1463. X              (math-match-substring (symbol-name f) 1)
  1464. X            (symbol-name f))))
  1465. X    (list 'var
  1466. X          (intern base)
  1467. X          (intern (concat "var-" base))))
  1468. X    f)
  1469. X)
  1470. X
  1471. X;;; Expand a function call using "lambda" notation.
  1472. X(defun math-build-call (f args)
  1473. X  (if (eq (car-safe f) 'calcFunc-lambda)
  1474. X      (if (= (length args) (- (length f) 2))
  1475. X      (let ((argnames (cdr f))
  1476. X        (argvals args)
  1477. X        (res (nth (1- (length f)) f)))
  1478. X        (while argvals 
  1479. X          (setq res (math-expr-subst res (car argnames) (car argvals))
  1480. X            argnames (cdr argnames)
  1481. X            argvals (cdr argvals)))
  1482. X        res)
  1483. X    (cons 'calcFunc-call (cons (math-calcFunc-to-var f) args)))
  1484. X    (cons f args))
  1485. X)
  1486. X
  1487. X(defun calcFunc-call (f &rest args)
  1488. X  (setq args (math-build-call (math-var-to-calcFunc f) args))
  1489. X  (if (eq (car-safe args) 'calcFunc-call)
  1490. X      args
  1491. X    (math-normalize args))
  1492. X)
  1493. X
  1494. X(defun calcFunc-apply (f args)
  1495. X  (or (Math-vectorp args)
  1496. X      (math-reject-arg args 'vectorp))
  1497. X  (apply 'calcFunc-call (cons f (cdr args)))
  1498. X)
  1499. X
  1500. X
  1501. X
  1502. X;;;; Vectors.
  1503. X
  1504. X;;; Return the dimensions of a matrix as a list.  [l x] [Public]
  1505. X(defun math-mat-dimens (m)
  1506. X  (if (math-vectorp m)
  1507. X      (if (math-matrixp m)
  1508. X      (cons (1- (length m))
  1509. X        (math-mat-dimens (nth 1 m)))
  1510. X    (list (1- (length m))))
  1511. X    nil)
  1512. X)
  1513. X
  1514. X
  1515. X;;; Apply a function elementwise to vector A.  [V X V; N X N] [Public]
  1516. X(defun math-map-vec (f a)
  1517. X  (if (math-vectorp a)
  1518. X      (cons 'vec (mapcar f (cdr a)))
  1519. X    (funcall f a))
  1520. X)
  1521. X
  1522. X(defun math-dimension-error ()
  1523. X  (calc-record-why "Dimension error")
  1524. X  (signal 'wrong-type-argument nil)
  1525. X)
  1526. X
  1527. X
  1528. X;;; Build a vector out of a list of objects.  [Public]
  1529. X(defun math-build-vector (&rest objs)
  1530. X  (cons 'vec objs)
  1531. X)
  1532. X(fset 'calcFunc-vec (symbol-function 'math-build-vector))
  1533. X
  1534. X
  1535. X;;; Build a constant vector or matrix.  [Public]
  1536. X(defun math-make-vec (obj &rest dims)
  1537. X  (math-make-vec-dimen obj dims)
  1538. X)
  1539. X(fset 'calcFunc-cvec (symbol-function 'math-make-vec))
  1540. X
  1541. X(defun math-make-vec-dimen (obj dims)
  1542. X  (if dims
  1543. X      (if (natnump (car dims))
  1544. X      (if (or (cdr dims)
  1545. X          (not (math-numberp obj)))
  1546. X          (cons 'vec (copy-sequence
  1547. X              (make-list (car dims)
  1548. X                     (math-make-vec-dimen obj (cdr dims)))))
  1549. X        (cons 'vec (make-list (car dims) obj)))
  1550. X    (math-reject-arg (car dims) 'natnump))
  1551. X    obj)
  1552. X)
  1553. X
  1554. X
  1555. X;;; Coerce row vector A to be a matrix.  [V V]
  1556. X(defun math-row-matrix (a)
  1557. X  (if (and (Math-vectorp a)
  1558. X       (not (math-matrixp a)))
  1559. X      (list 'vec a)
  1560. X    a)
  1561. X)
  1562. X
  1563. X;;; Coerce column vector A to be a matrix.  [V V]
  1564. X(defun math-col-matrix (a)
  1565. X  (if (and (Math-vectorp a)
  1566. X       (not (math-matrixp a)))
  1567. X      (cons 'vec (mapcar (function (lambda (x) (list 'vec x))) (cdr a)))
  1568. X    a)
  1569. X)
  1570. X
  1571. X
  1572. X(defun calc-binary-op-fancy (name func arg ident unary)
  1573. X  (let ((n (prefix-numeric-value arg)))
  1574. X    (cond ((> n 1)
  1575. X       (calc-enter-result n
  1576. X                  name
  1577. X                  (list 'calcFunc-reduce
  1578. X                    (math-calcFunc-to-var func)
  1579. X                    (cons 'vec (calc-top-list-n n)))))
  1580. X      ((= n 1)
  1581. X       (if unary
  1582. X           (calc-enter-result 1 name (list unary (calc-top-n 1)))))
  1583. X      ((= n 0)
  1584. X       (if ident
  1585. X           (calc-enter-result 0 name ident)
  1586. X         (error "Argument must be nonzero")))
  1587. X      (t
  1588. X       (let ((rhs (calc-top-n 1)))
  1589. X         (calc-enter-result (- 1 n)
  1590. X                name
  1591. X                (mapcar (function
  1592. X                     (lambda (x)
  1593. X                       (list func x rhs)))
  1594. X                    (calc-top-list-n (- n) 2)))))))
  1595. X)
  1596. X
  1597. X(defun calc-unary-op-fancy (name func arg)
  1598. X  (let ((n (prefix-numeric-value arg)))
  1599. X    (cond ((> n 0)
  1600. X       (calc-enter-result n
  1601. X                  name
  1602. X                  (mapcar (function
  1603. X                       (lambda (x)
  1604. X                     (list func x)))
  1605. X                      (calc-top-list-n n))))
  1606. X      ((= n 0))
  1607. X      (t
  1608. X       (error "Argument must be positive"))))
  1609. X)
  1610. X
  1611. X
  1612. X;;; Apply a function elementwise to vectors A and B.  [O X O O] [Public]
  1613. X(defun math-map-vec-2 (f a b)
  1614. X  (if (math-vectorp a)
  1615. X      (if (math-vectorp b)
  1616. X      (cons 'vec (math-map-vec-2-step f (cdr a) (cdr b)))
  1617. X    (cons 'vec (math-map-vec-2-left f (cdr a) b)))
  1618. X    (if (math-vectorp b)
  1619. X    (cons 'vec (math-map-vec-2-right f a (cdr b)))
  1620. X      (funcall f a b)))
  1621. X)
  1622. X
  1623. X(defun math-map-vec-2-step (f a b)   ; [L X L L]
  1624. X  (cond
  1625. X   ((null a) (if b (math-dimension-error)))
  1626. X   ((null b) (math-dimension-error))
  1627. X   (t (cons (funcall f (car a) (car b))
  1628. X        (math-map-vec-2-step f (cdr a) (cdr b)))))
  1629. X)
  1630. X
  1631. X(defun math-map-vec-2-left (f a b)   ; [L X L N]
  1632. X  (and a
  1633. X       (cons (funcall f (car a) b)
  1634. X         (math-map-vec-2-left f (cdr a) b)))
  1635. X)
  1636. X
  1637. X(defun math-map-vec-2-right (f a b)   ; [L X N L]
  1638. X  (and b
  1639. X       (cons (funcall f a (car b))
  1640. X         (math-map-vec-2-right f a (cdr b))))
  1641. X)
  1642. X
  1643. X
  1644. X;;; Map a function over a vector symbolically. [Public]
  1645. X(defun math-symb-map (f mode args)
  1646. X  (let* ((func (math-var-to-calcFunc f))
  1647. X     (nargs (length args))
  1648. X     (ptrs (vconcat args))
  1649. X     (vflags (make-vector nargs nil))
  1650. X     (vec nil)
  1651. X     (i -1)
  1652. X     len cols obj expr)
  1653. X    (if (eq mode 'rows)
  1654. X    ()
  1655. X      (while (and (< (setq i (1+ i)) nargs)
  1656. X          (not (math-matrixp (aref ptrs i)))))
  1657. X      (if (< i nargs)
  1658. X      (if (eq mode 'elems)
  1659. X          (setq func (list 'lambda '(&rest x)
  1660. X                   (list 'math-symb-map
  1661. X                     (list 'quote f) '(quote elems) 'x))
  1662. X            mode 'rows)
  1663. X        (while (< i nargs)
  1664. X          (if (math-matrixp (aref ptrs i))
  1665. X          (aset ptrs i (math-transpose (aref ptrs i))))
  1666. X          (setq i (1+ i))))
  1667. X    (setq mode 'elems))
  1668. X      (setq i -1))
  1669. X    (while (< (setq i (1+ i)) nargs)
  1670. X      (setq obj (aref ptrs i))
  1671. X      (if (and (eq (car-safe obj) 'vec)
  1672. X           (or (eq mode 'elems)
  1673. X           (math-matrixp obj)))
  1674. X      (progn
  1675. X        (aset vflags i t)
  1676. X        (if len
  1677. X        (or (= (length obj) len)
  1678. X            (math-dimension-error))
  1679. X          (setq len (length obj))))))
  1680. X    (or len
  1681. X    (if (= nargs 1)
  1682. X        (math-reject-arg (aref ptrs 0) 'vectorp)
  1683. X      (math-reject-arg "At least one argument must be a vector")))
  1684. X    (while (> (setq len (1- len)) 0)
  1685. X      (setq expr nil
  1686. X        i -1)
  1687. X      (while (< (setq i (1+ i)) nargs)
  1688. X    (if (aref vflags i)
  1689. X        (progn
  1690. X          (aset ptrs i (cdr (aref ptrs i)))
  1691. X          (setq expr (nconc expr (list (car (aref ptrs i))))))
  1692. X      (setq expr (nconc expr (list (aref ptrs i))))))
  1693. X      (setq vec (cons (math-build-call func expr) vec)))
  1694. X    (if (eq mode 'cols)
  1695. X    (math-transpose (math-normalize (cons 'vec (nreverse vec))))
  1696. X      (math-normalize (cons 'vec (nreverse vec)))))
  1697. X)
  1698. X
  1699. X(defun calcFunc-map (func &rest args)
  1700. X  (math-symb-map func 'elems args)
  1701. X)
  1702. X
  1703. X(defun calcFunc-mapr (func &rest args)
  1704. X  (math-symb-map func 'rows args)
  1705. X)
  1706. X
  1707. X(defun calcFunc-mapc (func &rest args)
  1708. X  (math-symb-map func 'cols args)
  1709. X)
  1710. X
  1711. X(defun calcFunc-mapa (func arg)
  1712. X  (if (math-matrixp arg)
  1713. X      (math-symb-map func 'elems (cdr (math-transpose arg)))
  1714. X    (math-symb-map func 'elems arg))
  1715. X)
  1716. X
  1717. X(defun calcFunc-mapd (func arg)
  1718. X  (if (math-matrixp arg)
  1719. X      (math-symb-map func 'elems (cdr arg))
  1720. X    (math-symb-map func 'elems arg))
  1721. X)
  1722. X
  1723. X
  1724. X;;; "Reduce" a function over a vector (left-associatively).  [O X V] [Public]
  1725. X(defun math-reduce-vec (f a)
  1726. X  (if (math-vectorp a)
  1727. X      (if (cdr a)
  1728. X      (math-reduce-vec-step f (car (cdr a)) (cdr (cdr a)))
  1729. X    0)
  1730. X    a)
  1731. X)
  1732. X
  1733. X(defun math-reduce-vec-step (f tot a)   ; [O X O L]
  1734. X  (if a
  1735. X      (math-reduce-vec-step f
  1736. X                (funcall f tot (car a))
  1737. X                (cdr a))
  1738. X    tot)
  1739. X)
  1740. X
  1741. X;;; Reduce a function over the columns of matrix A.  [V X V] [Public]
  1742. X(defun math-reduce-cols (f a)
  1743. X  (if (math-matrixp a)
  1744. X      (cons 'vec (math-reduce-cols-col-step f (cdr a) 1 (length (nth 1 a))))
  1745. X    a)
  1746. X)
  1747. X
  1748. X(defun math-reduce-cols-col-step (f a col cols)
  1749. X  (and (< col cols)
  1750. X       (cons (math-reduce-cols-row-step f (nth col (car a)) col (cdr a))
  1751. X         (math-reduce-cols-col-step f a (1+ col) cols)))
  1752. X)
  1753. X
  1754. X(defun math-reduce-cols-row-step (f tot col a)
  1755. X  (if a
  1756. X      (math-reduce-cols-row-step f
  1757. X                 (funcall f tot (nth col (car a)))
  1758. X                 col
  1759. X                 (cdr a))
  1760. X    tot)
  1761. X)
  1762. X
  1763. X
  1764. X;;; Reduce a function over a vector symbolically. [Public]
  1765. X(defun calcFunc-reduce (func vec)
  1766. X  (if (math-matrixp vec)
  1767. X      (let (expr row)
  1768. X    (setq func (math-var-to-calcFunc func))
  1769. X    (or (math-vectorp vec)
  1770. X        (math-reject-arg vec 'vectorp))
  1771. X    (while (setq vec (cdr vec))
  1772. X      (setq row (car vec))
  1773. X      (while (setq row (cdr row))
  1774. X        (setq expr (if expr
  1775. X               (math-build-call func (list expr (car row)))
  1776. X             (car row)))))
  1777. X    (math-normalize expr))
  1778. X    (calcFunc-reducer func vec))
  1779. X)
  1780. X
  1781. X(defun calcFunc-reducer (func vec)
  1782. X  (setq func (math-var-to-calcFunc func))
  1783. X  (or (math-vectorp vec)
  1784. X      (math-reject-arg vec 'vectorp))
  1785. X  (let ((expr (car (setq vec (cdr vec)))))
  1786. X    (or expr
  1787. X    (math-reject-arg vec "Vector is empty"))
  1788. X    (while (setq vec (cdr vec))
  1789. X      (setq expr (math-build-call func (list expr (car vec)))))
  1790. X    (math-normalize expr))
  1791. X)
  1792. X
  1793. X(defun calcFunc-reducec (func vec)
  1794. X  (if (math-matrixp vec)
  1795. X      (calcFunc-reducer func (math-transpose vec))
  1796. X    (calcFunc-reducer func vec))
  1797. X)
  1798. X
  1799. X(defun calcFunc-reducea (func vec)
  1800. X  (if (math-matrixp vec)
  1801. X      (cons 'vec
  1802. X        (mapcar (function (lambda (x) (calcFunc-reducer func x)))
  1803. X            (cdr vec)))
  1804. X    (calcFunc-reducer func vec))
  1805. X)
  1806. X
  1807. X(defun calcFunc-reduced (func vec)
  1808. X  (if (math-matrixp vec)
  1809. X      (cons 'vec
  1810. X        (mapcar (function (lambda (x) (calcFunc-reducer func x)))
  1811. X            (cdr (math-transpose vec))))
  1812. X    (calcFunc-reducer func vec))
  1813. X)
  1814. X
  1815. X
  1816. X;;; Multiply matrix vector element lists A and B.  [L L L]
  1817. X(defun math-mul-mats (a b)
  1818. X  (and a
  1819. X       (cons (cons 'vec (math-mul-mat-row (car a) b))
  1820. X         (math-mul-mats (cdr a) b)))
  1821. X)
  1822. X
  1823. X(defun math-mul-mat-row (a b)   ; [L L L]
  1824. X  (if (math-no-empty-rows b)
  1825. X      (cons
  1826. X       (math-reduce-vec 'math-add
  1827. X            (math-map-vec-2 'math-mul
  1828. X                    a
  1829. X                    (cons 'vec (mapcar 'car b))))
  1830. X       (math-mul-mat-row a (mapcar 'cdr b)))
  1831. X    (if (math-list-all-nil b)
  1832. X    nil
  1833. X      (math-dimension-error)))
  1834. X)
  1835. X
  1836. X(defun math-no-empty-rows (a)   ; [P L]
  1837. X  (or (null a)
  1838. X      (and (consp (car a))
  1839. X       (math-no-empty-rows (cdr a))))
  1840. X)
  1841. X
  1842. X(defun math-list-all-nil (a)   ; [P L]
  1843. X  (or (null a)
  1844. X      (and (null (car a))
  1845. X       (math-list-all-nil (cdr a))))
  1846. X)
  1847. X
  1848. X
  1849. X;;; Return the number of elements in vector V.  [Public]
  1850. X(defun math-vec-length (v)
  1851. X  (if (math-vectorp v)
  1852. X      (1- (length v))
  1853. X    0)
  1854. X)
  1855. X(fset 'calcFunc-vlen (symbol-function 'math-vec-length))
  1856. X
  1857. X;;; Get the Nth row of a matrix.
  1858. X(defun math-mat-row (mat n)
  1859. X  (elt mat n)
  1860. X)
  1861. X
  1862. X(defun calcFunc-mrow (mat n)   ; [Public]
  1863. X  (and (integerp (setq n (math-check-integer n)))
  1864. X       (> n 0)
  1865. X       (math-vectorp mat)
  1866. X       (nth n mat))
  1867. X)
  1868. X
  1869. X;;; Get the Nth column of a matrix.
  1870. X(defun math-mat-col (mat n)
  1871. X  (cons 'vec (mapcar (function (lambda (x) (elt x n))) (cdr mat)))
  1872. X)
  1873. X
  1874. X(defun calcFunc-mcol (mat n)   ; [Public]
  1875. X  (and (integerp (setq n (math-check-integer n)))
  1876. X       (> n 0)
  1877. X       (math-vectorp mat)
  1878. X       (if (math-matrixp mat)
  1879. X       (and (< n (length (nth 1 mat)))
  1880. X        (math-mat-col mat n))
  1881. X     (nth n mat)))
  1882. X)
  1883. X
  1884. X;;; Remove the Nth row from a matrix.
  1885. X(defun math-mat-less-row (mat n)
  1886. X  (if (<= n 0)
  1887. X      (cdr mat)
  1888. X    (cons (car mat)
  1889. X      (math-mat-less-row (cdr mat) (1- n))))
  1890. X)
  1891. X
  1892. X(defun calcFunc-mrrow (mat n)   ; [Public]
  1893. X  (and (integerp (setq n (math-check-integer n)))
  1894. X       (> n 0)
  1895. X       (< n (length mat))
  1896. X       (math-mat-less-row mat n))
  1897. X)
  1898. X
  1899. X;;; Remove the Nth column from a matrix.
  1900. X(defun math-mat-less-col (mat n)
  1901. X  (cons 'vec (mapcar (function (lambda (x) (math-mat-less-row x n)))
  1902. X             (cdr mat)))
  1903. X)
  1904. X
  1905. X(defun calcFunc-mrcol (mat n)   ; [Public]
  1906. X  (and (integerp (setq n (math-check-integer n)))
  1907. X       (> n 0)
  1908. X       (if (math-matrixp mat)
  1909. X       (and (< n (length (nth 1 mat)))
  1910. X        (math-mat-less-col mat n))
  1911. X     (math-mat-less-row mat n)))
  1912. X)
  1913. X
  1914. X(defun math-get-diag (mat)   ; [Public]
  1915. X  (if (math-square-matrixp mat)
  1916. X      (cons 'vec (math-get-diag-step (cdr mat) 1))
  1917. X    (calc-record-why 'math-square-matrixp mat)
  1918. X    (list 'calcFunc-getdiag mat))
  1919. X)
  1920. X(fset 'calcFunc-getdiag (symbol-function 'math-get-diag))
  1921. X
  1922. X(defun math-get-diag-step (row n)
  1923. X  (and row
  1924. X       (cons (nth n (car row))
  1925. X         (math-get-diag-step (cdr row) (1+ n))))
  1926. X)
  1927. X
  1928. X(defun math-transpose (mat)   ; [Public]
  1929. X  (if (math-vectorp mat)
  1930. X      (if (math-matrixp mat)
  1931. X      (cons 'vec
  1932. X        (math-trn-step mat 1 (length (nth 1 mat))))
  1933. X    (math-col-matrix mat))
  1934. X    (and (math-numberp mat)
  1935. X     mat))
  1936. X)
  1937. X(fset 'calcFunc-trn (symbol-function 'math-transpose))
  1938. X
  1939. X(defun calcFunc-ctrn (mat)
  1940. X  (let ((trn (math-transpose mat)))
  1941. X    (and trn
  1942. X     (math-conj trn)))
  1943. X)
  1944. X
  1945. X(defun math-trn-step (mat col cols)
  1946. X  (and (< col cols)
  1947. X       (cons (math-mat-col mat col)
  1948. X         (math-trn-step mat (1+ col) cols)))
  1949. X)
  1950. X
  1951. X(defun math-arrange-vector (vec cols)   ; [Public]
  1952. X  (if (and (math-vectorp vec) (integerp cols))
  1953. X      (let* ((flat (math-flatten-vector vec))
  1954. X         (mat (list 'vec))
  1955. X         next)
  1956. X    (if (<= cols 0)
  1957. X        (nconc mat flat)
  1958. X      (while (>= (length flat) cols)
  1959. X        (setq next (nthcdr cols flat))
  1960. X        (setcdr (nthcdr (1- cols) flat) nil)
  1961. X        (setq mat (nconc mat (list (cons 'vec flat)))
  1962. X          flat next))
  1963. X      (if flat
  1964. X          (setq mat (nconc mat (list (cons 'vec flat)))))
  1965. X      mat)))
  1966. X)
  1967. X(fset 'calcFunc-arrange (symbol-function 'math-arrange-vector))
  1968. X
  1969. X(defun math-flatten-vector (vec)   ; [L V]
  1970. X  (if (math-vectorp vec)
  1971. X      (apply 'append (mapcar 'math-flatten-vector (cdr vec)))
  1972. X    (list vec))
  1973. X)
  1974. X
  1975. X
  1976. X;;; Copy a matrix.  [Public]
  1977. X(defun math-copy-matrix (m)
  1978. X  (if (math-vectorp (nth 1 m))
  1979. X      (cons 'vec (mapcar 'copy-sequence (cdr m)))
  1980. X    (copy-sequence m))
  1981. X)
  1982. X
  1983. X;;; Convert a scalar or vector into an NxN diagonal matrix.  [Public]
  1984. X(defun math-diag-matrix (a &optional n)
  1985. X  (and n (not (integerp n))
  1986. X       (setq n (math-check-fixnum n)))
  1987. X  (if (math-vectorp a)
  1988. X      (if (and n (/= (length a) (1+ n)))
  1989. X      (list 'calcFunc-diag a n)
  1990. X    (if (math-matrixp a)
  1991. X        (if (and n (/= (length (elt a 1)) (1+ n)))
  1992. X        (list 'calcFunc-diag a n)
  1993. X          a)
  1994. X      (cons 'vec (math-diag-step (cdr a) 0 (1- (length a))))))
  1995. X    (if n
  1996. X    (cons 'vec (math-diag-step (make-list n a) 0 n))
  1997. X      (list 'calcFunc-diag a)))
  1998. X)
  1999. X(fset 'calcFunc-diag (symbol-function 'math-diag-matrix))
  2000. X
  2001. X(defun math-diag-step (a n m)
  2002. X  (if (< n m)
  2003. X      (cons (cons 'vec
  2004. X          (nconc (make-list n 0)
  2005. X             (cons (car a)
  2006. X                   (make-list (1- (- m n)) 0))))
  2007. X        (math-diag-step (cdr a) (1+ n) m))
  2008. X    nil)
  2009. X)
  2010. SHAR_EOF
  2011. echo "End of part 6"
  2012. echo "File calc-ext.el is continued in part 7"
  2013. echo "7" > s2_seq_.tmp
  2014. exit 0
  2015.